home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Appls / print.f < prev    next >
Encoding:
FORTH Source  |  1989-09-19  |  7.5 KB  |  359 lines
  1. \ Print a Source Code file with Header
  2. \ Convert TABS to spaces.
  3. \ Output text to optional file if specified.
  4. \ Print Linenumbers unless '-n' option selected.
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1988 Phil Burk
  8. \
  9. \ MOD: PLB 9/19/89 Close PRT: if error with input file.
  10.  
  11. exists? includes
  12. .IF getmodule includes
  13. .ELSE include? preferences ji:intuition/preferences.j
  14. .THEN
  15.  
  16. include? dolines ju:dolines
  17.  
  18. decimal
  19.  
  20. ANEW TASK-PRINT.F
  21.  
  22. : GetPrefs() ( pref size -- , read preferences info )
  23.     intuition?
  24.     callvoid>abs intuition_lib getprefs
  25. ;
  26.  
  27. \ Printer characteristics.
  28. preferences MY-PREF
  29. variable PR-LEFT
  30. variable PR-RIGHT
  31. variable PR-LINES/PAGE
  32. variable PR-CHARS/LINE
  33.  
  34. 128 constant PR_MAX_CHARS
  35.  
  36. \ Header to hold filename and page count.
  37. variable PR-HEADER pr_max_chars 2+ allot
  38. variable PR-NUM-BUFFER 16 allot ( hold line numbers )
  39. variable PR-LINE-BUFFER pr_max_chars 2+ allot
  40. variable PR-INFILE-NAME filename_size allot 
  41. variable PR-OUTFILE-NAME filename_size allot 
  42.  
  43. variable PR-LINE-OUT  \ num chars in line so far
  44. variable PR-IF-NUMBER
  45. variable PR-OFFSET
  46. variable PR-PAGE-NUMBER
  47. variable PR-LINE-NUMBER
  48. variable PR-LINES-SOFAR
  49. variable PR-PRT-FILEID
  50. variable PR-ERROR
  51. variable PR-TAB-WIDTH
  52.  
  53. 70 pr-chars/line !
  54. 8 pr-tab-width !
  55.  
  56. : GET.PREFS ( -- )
  57.     my-pref
  58.     sizeof() preferences
  59.     getprefs()
  60. ;
  61.  
  62. : GET.PAGE.INFO ( -- , extract relevant information )
  63.     get.prefs
  64.     my-pref ..@ pf_printleftmargin pr-left !
  65.     my-pref ..@ pf_printrightmargin pr-right !
  66.     pr-right @ pr-left @ - 1+ pr-chars/line !
  67.     my-pref ..@ pf_paperlength 8 - pr-lines/page !
  68. ;
  69.  
  70. : GET.DATE.STRING ( -- addr count , get date from DOS )
  71.     " DATE >RAM:ZZZZ_DATE" $dos
  72.     " RAM:ZZZZ_DATE" $fopen ?dup
  73.     IF  dup pad 40 fread 1- 0 max pad swap
  74.         rot fclose
  75.     ELSE pad 0
  76.     THEN
  77. ;
  78.  
  79. : PR.BUILD.HEADER ( -- , assemble date and name )
  80.     pr-header pr_max_chars BL fill  ( fill with blanks )
  81. \
  82. \ Put filename against right margin
  83.     pr-infile-name count  32 min 
  84.     pr-header pr-chars/line @ + over -
  85.     swap cmove
  86. \
  87. \ Put date against left margin
  88.     get.date.string dup
  89.     IF  bl scan ( skip past day )
  90.         pr-header swap cmove
  91.     ELSE 2drop
  92.     THEN
  93. ;
  94.  
  95. : PR.ADD.NUMBER ( -- , add page number to header )
  96.     pr-page-number @ n>text
  97.     pr-chars/line @ over - 2/
  98.     pr-header +
  99.     swap cmove
  100. ;
  101.  
  102. : PR.CR ( -- , send CR to printer )
  103.     pr-prt-fileid @ eol femit
  104.     1 pr-lines-sofar +!
  105. ;
  106.  
  107. : PR.TYPE ( addr count -- , output a string to printer )
  108.     dup
  109.     IF  pr-prt-fileid @ -rot dup>r fwrite
  110.         r> - dup pr-error !  ( set error if not written )
  111.         IF ." Write failed!" cr
  112.         THEN
  113.     ELSE 2drop
  114.     THEN
  115. ;
  116.  
  117. : PR.LINEOUT ( addr count -- , output a line to printer )
  118.     pr.type pr.cr
  119. ;
  120.  
  121. : PR.DO.HEADER ( -- , print header with page number )
  122.     1 pr-page-number +!
  123.     pr.add.number
  124.     pr-header pr-chars/line @ pr.lineout
  125.     pr.cr
  126. ;
  127.  
  128. : PR.NEW.PAGE ( -- , skip to new page )
  129.     pr-lines-sofar @
  130.     IF  pr-prt-fileid @ 12 femit
  131.         0 pr-lines-sofar !
  132.     THEN
  133. ;
  134.  
  135. : PR.LINE.DUMP ( -- , dump current line to printer )
  136.     pr-line-buffer
  137.     pr-line-out @ pr-chars/line @ pr-offset @ - min
  138.     pr.lineout 
  139. ;
  140.  
  141. : PR.EMIT ( char -- , add char to line buffer )
  142.     pr-line-out @ dup 1+ pr-line-out !
  143.     pr-line-buffer + c!
  144. ;
  145.  
  146. : PR.TAB ( -- , simulate tab )
  147.     pr-tab-width @
  148.     pr-line-out @ pr-tab-width @ mod
  149.     - 0
  150.     DO bl pr.emit
  151.     LOOP
  152. ;
  153.  
  154. 9 constant TAB_CHAR
  155.  
  156. : PR.LINE.FULL? ( -- if_full )
  157.     pr-chars/line @
  158.     pr-offset @ - ( max allowed )
  159.     pr-line-out @ <=
  160. ;
  161.  
  162. : PR.SCAN.CHARS ( addr numc -- addr' numc' , add characters to buf )
  163. \ Convert tabs to spaces.
  164.     0 pr-line-out !
  165.     BEGIN ( -- addr numc )
  166.         dup 0>
  167.         pr.line.full? not and
  168.     WHILE
  169.         over c@ dup tab_char =
  170.         IF drop pr.tab
  171.         ELSE pr.emit
  172.         THEN
  173.         1- swap 1+ swap  ( adjust addr and count )
  174.     REPEAT
  175. ;
  176.  
  177. : PR.ONE.LINE ( addr count -- addr' count' )
  178. \ Print header every time lines/page hit.
  179.     pr-lines-sofar @ pr-lines/page @ mod 0=
  180.     IF  pr.do.header
  181.     THEN
  182. \
  183. \ Print line numbers or whatever.
  184.     pr-num-buffer pr-offset @ pr.type
  185. \
  186. \ Print text.
  187.     pr.scan.chars
  188.     pr.line.dump
  189. \
  190. \ Form Feed if at end of page.
  191.     pr-lines-sofar @ pr-lines/page @ =
  192.     IF pr.new.page
  193.     THEN
  194. ;
  195.  
  196. : PR.CLEAR.NUMBER ( -- )
  197.     pr-num-buffer 16 bl fill
  198. ;
  199.  
  200. : PR.NUMBER.LINE ( -- , put line number in buffer )
  201.     pr.clear.number
  202.     pr-line-number @ n>text
  203.     dup 3 max dup 1+ pr-offset ! ( addr count width )
  204.     pr-num-buffer + over - swap cmove
  205. ;
  206.  
  207. : PR.LINE  ( $line -- , process line from DOLINES )
  208.     1 pr-line-number +!
  209.     pr-if-number @
  210.     IF  pr.number.line
  211.     THEN
  212.     count
  213.     BEGIN
  214.         pr.one.line
  215.         pr.clear.number
  216.         dup 0> not
  217.         pr-error @ 0= 0= OR
  218.     UNTIL
  219.     2drop
  220. ;
  221.  
  222. : FORCEUPPER ( char -- char' )
  223.     dup ascii a ascii z within?
  224.     IF ascii a - ascii A +
  225.     THEN
  226. ;
  227.  
  228. : PR.OPTION? ( $word -- if_option , parse if option )
  229.   dup c@ 2 <
  230.   IF drop false
  231.   ELSE
  232.     dup 1+ c@   ascii -   =
  233.     IF  dup 2+ c@
  234.         forceupper
  235.         CASE
  236.         ascii N
  237.             OF pr-if-number off true
  238.             ENDOF ( -- a f )
  239.         ascii T
  240.             OF
  241.             dup count 2- swap 1+ ( -- c-2 a+2 )
  242.             tuck c!
  243.             number?
  244.             IF drop 16 min pr-tab-width !
  245.             THEN
  246.             true 
  247.             ENDOF
  248.             ." Unrecognized option! = " over $type cr
  249.             pr-error on
  250.         false swap
  251.         ENDCASE nip
  252.     ELSE drop false
  253.     THEN
  254.   THEN
  255. ;
  256.  
  257. : PR.PARSE.INPUT (  <infile> <outfile> <-n> <-t6> -- )
  258.     " PRT:" pr-outfile-name $move
  259.     0 pr-infile-name !
  260.     makeucase @
  261.     makeucase off
  262.     BEGIN
  263.         fileword
  264.         dup c@
  265.     WHILE
  266.         dup pr.option? not
  267.         IF  pr-infile-name @
  268.             IF pr-outfile-name $move
  269.             ELSE pr-infile-name $move
  270.             THEN
  271.         ELSE drop
  272.         THEN
  273.     REPEAT drop
  274.     pr-infile-name @ 0=
  275.     IF pr-error on
  276.     THEN
  277.     makeucase !
  278. ;
  279.  
  280. : .COMMAND ( -- <name> )
  281.     >in @
  282.     >in off
  283.     bl word $type
  284.     >in !
  285. ;
  286.  
  287. : PR.USAGE ( -- , print Instructions )
  288.     cr .command ."  V1.1 by Phil Burk (Written using JForth)" cr cr
  289.     ." Usage:  print infile {outfile} {-n} {-t8}" cr cr
  290.     ." Prints text from infile to outfile, printing headers" cr
  291.     ." and line numbers on each page. Default outfile = PRT:" cr
  292.     ."    -n = turns off line numbering" cr
  293.     ."    -ti = set tab width to i, eg. -t4" cr
  294. ;
  295.  
  296. : PR.REPORT ( --, report progress )
  297.     cr pr-infile-name $type ."  printed to "
  298.     pr-outfile-name $type cr
  299.     pr-line-number ? ."  lines." cr
  300. ;
  301.  
  302. : PR.TERM ( -- , clean up )
  303.     pr-prt-fileid @ ?dup
  304.     IF  pr-error @ not
  305.         IF  pr.new.page
  306.         THEN fclose
  307.         pr-prt-fileid off
  308.     THEN
  309.     pr-error @
  310.     IF pr.usage
  311.        10 retcode !  ( set DOS return code )
  312.     ELSE pr.report
  313.     THEN
  314. ;
  315.  
  316. : PR.ABORT  ( -- )
  317.     pr-error on
  318.     pr.term
  319.     abort
  320. ;
  321.  
  322. : PR.INIT ( <infile> <outfile> <-n> <-t6> -- error? , setup print system )
  323.     pr-error off
  324.     get.page.info
  325. \
  326.     ' pr.line is doline
  327.     ' pr.abort is doline.error  ( added 9/19/89 )
  328.     0 pr-page-number !
  329.     0 pr-line-number !
  330.     0 pr-lines-sofar !
  331.     0 pr-offset !
  332.     0 pr-prt-fileid !
  333.     8 pr-tab-width !
  334.     pr-if-number on
  335. \
  336.     pr.parse.input
  337.     pr.build.header
  338.     pr-error @ not
  339.     IF  pr-outfile-name new $fopen
  340.         dup pr-prt-fileid ! 0=
  341.         IF  pr-outfile-name $type
  342.             ."  could not be opened!" cr
  343.             pr-error on
  344.         THEN
  345.     THEN
  346.     pr-error @
  347. ;
  348.  
  349. : PRINT ( <infile> <outfile> <-n> <-t6> -- )
  350.     pr.init 0=
  351.     IF  pr-infile-name $dolines
  352.     THEN
  353.     pr-line-number @ 0= pr-error !
  354.     pr.term
  355. ;
  356.  
  357. cr ." Enter:  PRINT filename" cr
  358. ." to print a file to printer" cr
  359.